home *** CD-ROM | disk | FTP | other *** search
/ PC World 2006 February / PCWorld_2006-02_cd.bin / software / vyzkuste / audacity / audacity-win-1.2.4b.exe / {app} / Nyquist / xlinit.lsp < prev   
Lisp/Scheme  |  2002-09-16  |  2KB  |  68 lines
  1. ;; xlinit.lsp -- standard definitions and setup code for XLisp
  2. ;;
  3.  
  4.  
  5. (defun bt () (baktrace 6))
  6.  
  7. (defmacro setfn (a b) 
  8.   `(setf (symbol-function ',a) (symbol-function ',b)))
  9.  
  10. (setfn co continue)
  11. (setfn top top-level)
  12. (setfn res clean-up)
  13. (setfn up clean-up)
  14.  
  15. ;## display -- debugging print macro
  16. ;
  17. ; call like this (display "heading" var1 var2 ...)
  18. ; and get printout like this:
  19. ;   "heading : VAR1 = <value> VAR2 = <value> ...<CR>"
  20. ;
  21. ; returns:
  22. ;   (let ()
  23. ;     (format t "~A: " ,label)
  24. ;     (format t "~A = ~A  " ',item1 ,item1)
  25. ;     (format t "~A = ~A  " ',item2 ,item2)
  26. ;     ...)
  27. ;
  28. (defmacro display-macro (label &rest items)
  29.   (let ($res$)
  30.     (dolist ($item$ items)
  31.             (setq $res$ (cons
  32.                          `(format t "~A = ~A  " ',$item$ ,$item$)
  33.                          $res$)))
  34.     (append (list 'let nil `(format t "~A : " ,label))
  35.             (reverse $res$)
  36.             '((terpri)))))
  37.  
  38.  
  39. (defun display-on () (setfn display display-macro) t)
  40. (defun display-off () (setfn display or) nil)
  41. (display-on)
  42.  
  43. ; (objectp expr) - object predicate
  44. ;
  45. (defun objectp (x) (eq (type x) 'OBJ))
  46.  
  47.  
  48. ; (filep expr) - file predicate
  49. ;
  50. (defun filep (x) (eq (type x) 'FPTR))
  51.  
  52. (load "profile.lsp" :verbose NIL)
  53.  
  54. (setq *breakenable* t)
  55. (setq *tracenable* nil)
  56.  
  57. (defmacro defclass (name super locals class-vars)
  58.   (if (not (boundp name))
  59.     (if super
  60.     `(setq ,name (send class :new ',locals ',class-vars ,super))
  61.     `(setq ,name (send class :new ',locals ',class-vars)))))
  62.  
  63. ;(cond ((boundp 'application-file-name)
  64. ;       (load application-file-name)))
  65.  
  66. (setq *gc-flag* t)
  67.  
  68.